home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / UTILITY.S < prev   
Encoding:
Text File  |  1993-06-15  |  5.7 KB  |  199 lines
  1. ;* UTILITY.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Scoops: Miscellanea                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;   Error handler. Looks up the error message in the table and
  23. ;   prints it.
  24.  
  25.     (define error-handler
  26.       (let ((error-table
  27.         (let ((table (make-vector 8)))
  28.           (vector-set! table 0 " Invalid class definition ")
  29.           (vector-set! table 1 " Invalid option ")
  30.           (vector-set! table 2 " Class not defined ")
  31.           (vector-set! table 3 " Method has been deleted ")
  32.           (vector-set! table 4 " Method is not present ")
  33.           (vector-set! table 5 " Variable is not present")
  34.           (vector-set! table 6 " Not a Scoops Class")
  35.           (vector-set! table 7 " Class not compiled ")
  36.           table)))
  37.         (lambda (msg number flag)
  38.           (if flag
  39.               (error (vector-ref error-table number) msg)
  40.               (bkpt  (vector-ref error-table number) msg)))))
  41.  
  42.  
  43. ;   some functions defined globally which will be moved locally later
  44.  
  45.         (define %sc-class-description
  46.            (lambda (class)
  47.               (writeln " ")
  48.               (writeln "    CLASS DESCRIPTION    ")
  49.               (writeln "    ==================    ")
  50.               (writeln " ")
  51.               (writeln " NAME            : " (%sc-name class))
  52.               (writeln " CLASS VARS      : "
  53.                        (mapcar car (%sc-allcvs class)))
  54.               (writeln " INSTANCE VARS   : "
  55.                        (mapcar car (%sc-allivs class)))
  56.               (writeln " METHODS         : "
  57.                        (mapcar car (%sc-method-structure class)))
  58.               (writeln " MIXINS          : " (%sc-mixins class))
  59.               (writeln " CLASS COMPILED  : " (%sc-class-compiled class))
  60.               (writeln " CLASS INHERITED : " (%sc-class-inherited class))
  61.            ))
  62. ;
  63.  
  64.     (define %sc-inst-desc
  65.        (lambda (inst)
  66.          (letrec ((class (access %sc-class inst))
  67.                   (printvars
  68.                     (lambda (f1 f2)
  69.                       (if f1
  70.                           (begin
  71.                            (writeln "   " (caar f1) " : "
  72.                                     (cdr (assq (caar f1) f2)))
  73.                            (printvars (cdr f1) f2))))))
  74.             (writeln " ")
  75.             (writeln "  INSTANCE DESCRIPTION      ")
  76.             (writeln "  ====================      ")
  77.             (writeln " ")
  78.             (writeln " Instance of Class " (%sc-name class))
  79.             (writeln " ")
  80.             (writeln " Class Variables : ")
  81.             (printvars (%sc-allcvs class)
  82.                        (environment-bindings (%sc-class-env class)))
  83.             (writeln " ")
  84.             (writeln "Instance Variables :")
  85.             (printvars (%sc-allivs class) (environment-bindings inst))
  86.            )))
  87. ;
  88.  
  89. (define describe
  90.   (lambda (class-inst)
  91.     (if (vector? class-inst)
  92.         (begin
  93.           (%scoops-chk-class class-inst)
  94.           (%sc-class-description class-inst))
  95.         (%sc-inst-desc class-inst))))
  96.  
  97.  
  98. (define %scoops-chk-class-compiled
  99.   (lambda (name class)
  100.     (or (%sc-class-compiled class)
  101.         (error-handler name 7 #T))))
  102.  
  103. ; (rename-class (class new-name))
  104.  
  105. (macro rename-class
  106.   (lambda (e)
  107.     (let ((class (caadr e))
  108.           (new-name (cadadr e)))
  109.       `(begin
  110.          (%sc-name->class ',class)
  111.          (%sc-set-name ,class ',new-name)
  112.          (set! (access ,new-name user-initial-environment) ,class)
  113.          (putprop ',new-name ,new-name '%class)
  114.          ',new-name))))
  115.  
  116. ; (getcv class var)
  117.  
  118. (macro getcv
  119.   (lambda (e)
  120.     (let ((class (cadr e))
  121.           (var (caddr e)))
  122.       `(begin
  123.          (and (%sc-name->class ',class)
  124.               (%scoops-chk-class-compiled ',class ,class))
  125.          (send (%sc-class-env ,class) ,(%sc-concat "GET-" var))))))
  126.  
  127. ; (setcv class var val)
  128.  
  129. (macro setcv
  130.   (lambda (e)
  131.     (let ((class (cadr e))
  132.           (var (caddr e))
  133.           (val (cadddr e)))
  134.       `(begin
  135.          (and (%sc-name->class ',class)
  136.               (%scoops-chk-class-compiled ',class ,class))
  137.          (send (%sc-class-env ,class) ,(%sc-concat "SET-" var) ,val)))))
  138.  
  139. ; (class-compiled? class)
  140.  
  141. (define class-compiled?
  142.   (lambda (class)
  143.     (%scoops-chk-class class)
  144.     (%sc-class-compiled class)))
  145.  
  146.  
  147. ;  (class-of-object object)
  148.  
  149. (define class-of-object
  150.   (lambda (obj)
  151.     (%sc-name (access %sc-class obj))))
  152.  
  153. ; (name->class name)
  154.  
  155. (define name->class
  156.   (lambda (name)
  157.     (%sc-name->class name)))
  158.  
  159. ;
  160.  
  161. (define %sc-class-info
  162.   (lambda (fn)
  163.     (lambda (class)
  164.       (%scoops-chk-class class)
  165.       (mapcar car (fn class)))))
  166.  
  167. ;
  168.  
  169. (define methods (%sc-class-info %sc-method-values))
  170.  
  171. ;
  172.  
  173. (define all-methods (%sc-class-info %sc-method-structure))
  174.  
  175. ;
  176.  
  177. (define classvars (%sc-class-info %sc-cv))
  178.  
  179. ;
  180.  
  181. (define all-classvars (%sc-class-info %sc-allcvs))
  182.  
  183. ;
  184.  
  185. (define instvars (%sc-class-info %sc-iv))
  186.  
  187. ;
  188.  
  189. (define all-instvars (%sc-class-info %sc-allivs))
  190.  
  191.  
  192. ;
  193.  
  194. (define mixins
  195.   (lambda (class)
  196.     (%scoops-chk-class class)
  197.     (%sc-mixins class)))
  198.  
  199.